home *** CD-ROM | disk | FTP | other *** search
Option Explicit Type ToolType Pos As apiRect ' position on toolbar nr As Integer ' nr of tool Group As Integer ' group nr of tool Visible As Integer ' visible or not Enabled As Integer ' enabled or not qHelp As Integer ' use qHelp or not StatText As String ' status text MouseText As String ' qHelp text UseMouse As Integer ' us mouse or not CopyPicture As Integer ' copy picture or not End Type Dim mTools() As ToolType Dim oTools() As apiRect'ToolType Dim ToolSource() As Control Dim TooloTarget() As PictureBox Dim ToolcTarget() As PictureBox Dim ToolGroup As Integer Dim ToolLeft As Integer Dim qhloaded As Integer Dim qhExit As Integer Dim Toolbar As PictureBox Global MDIParent As Form Dim qHelp As Integer Dim FTTitle As String Dim FloatingToolbar As Form Dim mOver As Integer Dim ToolCnt As Integer Dim lw As Integer Dim ToolMenu As Control Dim UseFloatingTool As Integer Dim lblstatus As Label Dim cReady As String Global ChangeBar As Integer Global Const qhNoTool = -1 Global Const qhNotUsed = -2 Global Const qhNoBar = -3 Global Const qhAppExit = -4 Declare Function GetCursor Lib "User" () As Integer Sub vbQHCopyToolExt (TempTool As ToolType, nr As Integer, Source As Control, Target As PictureBox) Dim sosm As Integer, toar As Integer, lleft As Integer, rc As Integer Dim tRect As apiRect If ToolGroup < TempTool.Group Then ' check for new toolgroup ToolGroup = TempTool.Group ' if new toolgroup ToolLeft = ToolLeft + 5 ' space between tools End If mTools(nr).Pos.left = ToolLeft ' copy position of tool mTools(nr).Pos.top = 3 mTools(nr).Pos.right = Source.Width mTools(nr).Pos.bottom = Source.Height mTools(nr).nr = nr ' set toolnumber mTools(nr).Group = TempTool.Group ' set toolgroup mTools(nr).Visible = TempTool.Visible ' set toolprops mTools(nr).Enabled = TempTool.Enabled mTools(nr).qHelp = TempTool.qHelp mTools(nr).StatText = TempTool.StatText ' set stattext mTools(nr).MouseText = TempTool.MouseText ' set tooltext mTools(nr).UseMouse = TempTool.UseMouse mTools(nr).CopyPicture = TempTool.CopyPicture Set ToolSource(nr) = Source ' set source Set TooloTarget(nr) = Target ' set target If mTools(nr).CopyPicture Then Source.Parent.Source.Picture = Source.Picture GetWindowRect Source.Parent.Source.hWnd, tRect ' get source rect sosm = Source.Parent.ScaleMode ' save prop Source.Parent.ScaleMode = 3 ' set new prop toar = Target.AutoRedraw ' set props Target.AutoRedraw = True ' copy tools image rc = StretchBlt(Target.hDC, ToolLeft, 3, Source.Parent.Source.Width, Source.Parent.Source.Height, Source.Parent.Source.hDC, 0, 0, tRect.right - tRect.left, tRect.bottom - tRect.top, srcCopy) Target.Refresh Target.Picture = Target.Image ' set props Target.AutoRedraw = toar Source.Parent.ScaleMode = sosm End If ToolLeft = ToolLeft + Source.Width - 1 End Sub Sub vbQHelpExt (Target As PictureBox) Dim i As Integer, tn As Integer Dim tRect As apiRect, mRect As apiRect Dim mPos As apiPoint If Not mOver Then ' if first time in function mOver = True GetWindowRect Target.hWnd, tRect ' get toolbar rect GetCursorPos mPos ' get and calc cursor position mPos.X = mPos.X - tRect.left: mPos.Y = mPos.Y - tRect.top i = vbQHGetToolNr(Target, mPos) ' get active tool If i = qhNoTool Then ' invoke help i = vbQHToolBarMove(Target) ' move toolbar Else i = vbQHGetHelp(Target, i, qHelp) ' get help End If If qhExit Then ' app closed tn = qhAppExit Else tn = i ' toolnr End If vbQHelpBreak: vbQHTools tn If Not qhExit Then ' app closed lblstatus = cReady End If mOver = False End If End Sub Sub vbQHCalcToolPos (Target As PictureBox) Dim i As Integer, t As Integer, osm As Integer, oar As Integer, rc As Integer Dim tRect As apiRect If Target.ScaleWidth = lw Then Exit Sub lw = Target.ScaleWidth osm = Target.ScaleMode oar = Target.AutoRedraw Target.ScaleMode = 3 Target.AutoRedraw = True Target.Picture = LoadPicture("") Target.Cls ToolGroup = 0 ToolLeft = 0 t = 3'12 UseFloatingTool = True For i = 0 To ToolCnt - 1 If TooloTarget(i) = Toolbar Then If ToolGroup < mTools(i).Group Then ' check for new toolgroup ToolGroup = mTools(i).Group ' if new toolgroup ToolLeft = ToolLeft + 5 ' space between tools End If ToolSource(i).Parent.Source.Picture = ToolSource(i).Picture GetWindowRect ToolSource(i).Parent.Source.hWnd, tRect ' get source rect ' copy tools image If ToolLeft + ToolSource(i).Width > Target.ScaleWidth - 5 Then t = t + ToolSource(i).Height + 5 ToolLeft = 5 End If oTools(i).left = ToolLeft oTools(i).top = t oTools(i).right = ToolSource(i).Width oTools(i).bottom = ToolSource(i).Height rc = StretchBlt(Target.hDC, ToolLeft, t, ToolSource(i).Width, ToolSource(i).Height, ToolSource(i).Parent.Source.hDC, 0, 0, tRect.right - tRect.left, tRect.bottom - tRect.top, srcCopy) ToolLeft = ToolLeft + ToolSource(i).Width - 1 Set ToolcTarget(i) = Target If Not mTools(i).Enabled Then mTools(i).Enabled = True vbQHEnabled i, False End If End If Next i Target.ScaleMode = osm Target.AutoRedraw = oar End Sub Sub vbQHEnabled (MyTool As Integer, Flag As Integer) Dim oar As Integer Dim tRect As apiRect Dim pb As PictureBox If mTools(MyTool).CopyPicture And mTools(MyTool).Enabled <> Flag Then ' if Picture is used If UseFloatingTool Then ' if tool is on floating toolbar Set pb = ToolcTarget(MyTool) tRect = oTools(MyTool) Else ' if tool is on toolbar Set pb = TooloTarget(MyTool) tRect.left = mTools(MyTool).Pos.left tRect.top = mTools(MyTool).Pos.top tRect.right = mTools(MyTool).Pos.right tRect.bottom = mTools(MyTool).Pos.bottom End If If Flag Then ' enable tool vbQHMakeEnable tRect, pb, MyTool Else vbQHMakeDisable tRect, pb ' disable tool End If If UseFloatingTool And Not ChangeBar Then ' if tool is on floating toolbar Set pb = TooloTarget(MyTool) tRect.left = mTools(MyTool).Pos.left tRect.top = mTools(MyTool).Pos.top tRect.right = mTools(MyTool).Pos.right tRect.bottom = mTools(MyTool).Pos.bottom If Flag Then ' enable tool vbQHMakeEnable tRect, pb, MyTool Else vbQHMakeDisable tRect, pb ' disable tool End If End If mTools(MyTool).Enabled = Flag pb.Picture = pb.Image End If End Sub Sub vbQHExit (MyForm As Form) Dim i As Integer On Error Resume Next Select Case MyForm.hWnd Case MDIParent.hWnd qhExit = True For i = 0 To Forms.Count - 1 If Forms(i).hWnd <> MyForm.hWnd Then Unload Forms(i) Next i Case FloatingToolbar.hWnd Unload ToolSource(0).Parent SetChild MyForm.hWnd, MDIParent.hWnd, False If Not Toolbar.Visible Then ToolMenu.Checked = False UseFloatingTool = False End Select End Sub Sub vbQHFakeMove (MyForm As Form) Dim dc As Integer, l As Integer, t As Integer Dim cRect As apiRect, mRect As apiRect, lRect As apiRect Dim mPos As apiPoint, oldPos As apiPoint, oPoint As apiPoint Dim tRect As apiRect, dRect As apiRect MP_Alt = Screen.MousePointer ' save pointer zGetInnerRect MDIParent, cRect ' get mouse rect cRect.bottom = cRect.top + MDIParent.ScaleHeight / Screen.TwipsPerPixelY + 1 If MyForm.MDIChild Then ClipCursor cRect ' clip mouse region End If dc = CreateDC("DISPLAY", 0, 0, 0) ' create dc GetCursorPos mPos ' get mouse position oldPos = mPos GetWindowRect MyForm.hWnd, mRect ' get rect to move oPoint.X = mPos.X - mRect.left ' get x offset oPoint.Y = mPos.Y - mRect.top ' get y offset GetWindowRect Toolbar.hWnd, tRect ' get rect, not to move If Toolbar.Align = 1 Then lRect.left = tRect.left lRect.top = cRect.bottom - tRect.bottom + tRect.top lRect.right = tRect.right lRect.bottom = cRect.bottom Else lRect.left = tRect.left lRect.top = cRect.top' - tRect.bottom + tRect.top lRect.right = tRect.right lRect.bottom = cRect.top + tRect.bottom - tRect.top dRect = tRect tRect = lRect lRect = dRect End If dRect = mRect DrawFocusRect dc, dRect ' draw rect Do DoEvents Screen.MousePointer = 1 ' set mousepointer oldPos = mPos GetCursorPos mPos ' get mouse position If oldPos.X <> mPos.X Or oldPos.Y <> mPos.Y Then DrawFocusRect dc, dRect ' delete rect, calc new pos mRect.left = mRect.left - oldPos.X + mPos.X mRect.top = mRect.top - oldPos.Y + mPos.Y mRect.right = mRect.right - oldPos.X + mPos.X mRect.bottom = mRect.bottom - oldPos.Y + mPos.Y If zisPointInRect(mPos, tRect) Then dRect = tRect ' don't move in this rect ElseIf zisPointInRect(mPos, lRect) Then dRect = lRect ' don't move in this rect Else dRect = mRect ' move rect End If DrawFocusRect dc, dRect ' draw rect End If Loop While GetKeyState(1) < 0 ' while mouse_down DrawFocusRect dc, dRect ' delete rect dc = DeleteDC(dc) ' delete dc If MyForm.MDIChild Then cRect.left = 0: cRect.right = GetSystemMetrics(0) cRect.top = 0: cRect.bottom = GetSystemMetrics(1) ClipCursor cRect ' clip mouse End If If zisPointInRect(mPos, tRect) Then ' if mouse over toolbar Toolbar.Align = 1 MakeStatusBar Toolbar Toolbar.Visible = True ' show toolbar Toolbar.Parent.Show Unload MyForm ' hide form ElseIf zisPointInRect(mPos, lRect) Then Toolbar.Align = 2 MakeStatusBar Toolbar Toolbar.Visible = True ' show toolbar Toolbar.Parent.Show Unload MyForm ' hide form Else ' else MyForm.Cls ' clear form If FloatingToolbar.MDIChild Then l = mRect.left - MDIParent.Left / Screen.TwipsPerPixelX - GetSystemMetrics(32) t = mRect.top - MDIParent.Top / Screen.TwipsPerPixelY - GetSystemMetrics(4) - GetSystemMetrics(15) - GetSystemMetrics(33) Else l = mPos.X - oPoint.X t = mPos.Y - oPoint.Y End If MyForm.Move l * Screen.TwipsPerPixelX, t * Screen.TwipsPerPixelY ' move form End If Screen.MousePointer = MP_Alt ' restore old mousepointer End Sub Private Function vbQHGetHelp (Target As Control, nr As Integer, qHelp As Integer) As Integer Dim ch As Integer, px As Integer, py As Integer, rc As Integer', qhTool As Integer Dim MouseState As Integer, fEnter As Integer, mDown As Integer Dim temp$ Dim mPos As apiPoint, cExt As apiPoint Dim tRect As apiRect, aRect As apiRect, mRect As apiRect Dim wPoint As apiPoint, tPoint As apiPoint Dim StartTime As Single, StopTime As Single Dim sm As Integer, ds As Integer, dm As Integer, ar As Integer GetWindowRect Target.hWnd, tRect ' Position of Toolbars vbQHGetHelp = qhNoTool ' Return value fEnter = True ' just entered function Do NewCursorPos: ' Mouse moved GetCursorPos mPos ' Cursorposition DoEvents ' relative position of mouse If qhExit Then If qhloaded Then ' if QuickHelp is loaded qhloaded = False ' unload it Unload wndQHelp End If Exit Function End If mPos.X = mPos.X - tRect.left: mPos.Y = mPos.Y - tRect.top ' if mouse is not over tool If UseFloatingTool Then mRect = oTools(nr) Else mRect = mTools(nr).Pos End If 'mTools(nr).Pos If Not zisPointInRectExt(mPos, mRect) Then nr = vbQHGetToolNr(Target, mPos) ' get new tool If nr = qhNoTool Then ' if there is no new tool Exit Do ' exit Else ' else If qhloaded Then ' if QuickHelp is loaded qhloaded = False ' unload it Unload wndQHelp End If WaitZehntel 2 ' wait on further movements GoTo NewCursorPos ' and start again End If End If MouseState = GetKeyState(1) If MouseState < 0 Then ' if mouse_click MouseState = True Else MouseState = False End If 'If qhExit Then Exit Function If MouseState Then ' if mouse_click ' write status text If Len(mTools(nr).StatText) Then lblstatus.Caption = mTools(nr).StatText ' unload qHelp (if loaded) If qhloaded Then Unload wndQHelp: qhloaded = False sm = Target.ScaleMode ' save old props ds = Target.DrawStyle dm = Target.DrawMode ar = Target.AutoRedraw Target.ScaleMode = 3 ' set new props Target.DrawStyle = 0 Target.DrawMode = 13 Target.AutoRedraw = False Target.Refresh Do ' wait on mouse_up GetCursorPos tPoint ' get and calc cursor position tPoint.X = tPoint.X - tRect.left: tPoint.Y = tPoint.Y - tRect.top If zisPointInRectExt(tPoint, mRect) Then If Not mDown Then ' perform mouse_click rc = BitBlt(Target.hDC, mRect.left + 3, mRect.top + 3, mRect.right - 4, mRect.bottom - 4, Target.hDC, mRect.left + 2, mRect.top + 2, srcCopy) Target.Line (mRect.left + 2, mRect.top + 2)-(mRect.left + mRect.right - 2, mRect.top + 2), RGB(192, 192, 192) Target.Line (mRect.left + 2, mRect.top + 3)-(mRect.left + 2, mRect.top + mRect.bottom - 2), RGB(192, 192, 192) Target.Line (mRect.left + 1, mRect.top + 1)-(mRect.left + 1, mRect.top + mRect.bottom - 2), RGB(128, 128, 128) Target.Line (mRect.left + 1, mRect.top + 1)-(mRect.left + mRect.right - 2, mRect.top + 1), RGB(128, 128, 128) Target.Line (mRect.left + 2, mRect.top + mRect.bottom - 2)-(mRect.left + mRect.right - 2, mRect.top + mRect.bottom - 2), RGB(192, 192, 192)'RGB(255, 255, 255) Target.Line (mRect.left + mRect.right - 2, mRect.top + 2)-(mRect.left + mRect.right - 2, mRect.top + mRect.bottom - 1), RGB(192, 192, 192)'RGB(255, 255, 255) mDown = True End If Else ' if mouse not over tool If mDown Then Target.Refresh mDown = False End If DoEvents If qhExit Then Exit Function' if app closed Loop While GetKeyState(1) < 0 ' mouse_up Target.Refresh Target.ScaleMode = sm ' restore old props Target.DrawStyle = ds Target.DrawMode = dm Target.AutoRedraw = ar If mDown Then ' if tool clicked vbQHGetHelp = nr ' return toolnr GoTo vbQHGetHelpBreak ' break End If Else If qHelp Then ' if user wants qHelp If fEnter Then ' if just entered the function ' wait some time StartTime = GetTickCount() / 1000 Do StopTime = GetTickCount() / 1000 DoEvents ' if mouse_click start again If GetKeyState(1) < 0 GoTo NewCursorPos If qhExit Then Exit Function If StartTime + (5 / 10) <= StopTime Then Exit Do Loop fEnter = False End If If Not qhloaded Then ' if qHelp not loaded then Load wndQHelp ' load qHelp temp$ = mTools(nr).MouseText ' text for qHelp rc = zvbGetCursorExt(cExt) - 1 ' Cursorheight wndQHelp.CurrentX = 2 wndQHelp.CurrentY = 2 wndQHelp.Print temp$ ' write text, qhHeight, border wndQHelp.Height = (wndQHelp.TextHeight(temp$) + 4) * Screen.TwipsPerPixelX wndQHelp.Width = (wndQHelp.TextWidth(temp$) + 4) * Screen.TwipsPerPixelY wndQHelp.Line (0, 0)-(wndQHelp.Width / Screen.TwipsPerPixelX - 1, wndQHelp.Height / Screen.TwipsPerPixelY - 1), , B GetCursorPos wPoint ' calc position of window px = wPoint.X - (wndQHelp.Width / Screen.TwipsPerPixelX) / 2 + cExt.X - 1 If px < 0 Then ' if left pos is negative px = 0 ElseIf (px + wndQHelp.Width / Screen.TwipsPerPixelX) > GetSystemMetrics(0) Then ' if right border is not on screen px = GetSystemMetrics(0) - wndQHelp.Width / Screen.TwipsPerPixelX End If py = (wPoint.Y + cExt.Y - 1) If py + wndQHelp.Height / Screen.TwipsPerPixelY > GetSystemMetrics(1) Then ' if lower border is not on screen py = wPoint.Y - 2 - wndQHelp.Height / Screen.TwipsPerPixelY End If ' set new position of qHelp wndQHelp.Move px * Screen.TwipsPerPixelX, Screen.TwipsPerPixelY * py GetCursorPos tPoint ' get and calc cursor position tPoint.X = tPoint.X - tRect.left: tPoint.Y = tPoint.Y - tRect.top If zisPointInRectExt(tPoint, mRect) Then ' if cursor is over tool SetWindowPos wndQHelp.hWnd, -1, 0, 0, 0, 0, &H20 Or &H1 Or &H40 Or &H10 'Or &H8 Else ' if cursor is elsewhere Unload wndQHelp GoTo NewCursorPos ' start again End If qhloaded = True ' qHelp loaded successful End If ' Not qhloaded End If ' qHelp End If ' MouseState Loop vbQHGetHelpBreak: Unload wndQHelp ' unload qHelp qhloaded = False End Function Private Function vbQHGetToolNr (Target As Control, tPos As apiPoint) As Integer Dim i As Integer Dim tRect As apiRect vbQHGetToolNr = qhNoTool For i = 0 To ToolCnt - 1 ' check every tool for rect and target If UseFloatingTool Then tRect = oTools(i) Else tRect = mTools(i).Pos End If ' mTools(i).Pos If zisPointInRectExt(tPos, tRect) Then If Target = TooloTarget(i) Then If mTools(i).Enabled Then vbQHGetToolNr = i ' return toolnr End If Exit For ElseIf Target = ToolcTarget(i) Then If mTools(i).Enabled Then vbQHGetToolNr = i ' return toolnr End If Exit For End If End If Next i End Function Sub vbQHInitTools (cnt As Integer, MyWnd As Form, Target As PictureBox, MyMenu As Control, status As Label, cap As String) Static Init As Integer If Not Init Then ToolCnt = cnt ToolGroup = 0 ' init groups ToolLeft = 0 ' init left ReDim mTools(cnt - 1) ' alloc memory for tools ReDim oTools(cnt - 1) ReDim ToolSource(cnt - 1) ReDim TooloTarget(cnt - 1) ReDim ToolcTarget(cnt - 1) Set FloatingToolbar = MyWnd Set Toolbar = Target ' set props Set MDIParent = Target.Parent Set ToolMenu = MyMenu Set lblstatus = status Target.AutoRedraw = True Target.BackColor = BUTTON_FACE cReady = cap Init = True ' init successful End If End Sub Private Sub vbQHMakeDisable (tRect As apiRect, Target As PictureBox) Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer Dim lc As Long, dGrau As Long, hGrau As Long, Weiss As Long Dim osm As Integer dGrau = RGB(128, 128, 128) hGrau = RGB(192, 192, 192) Weiss = RGB(255, 255, 255) tRect.right = tRect.right + tRect.left tRect.bottom = tRect.bottom + tRect.top osm = Target.ScaleMode Target.ScaleMode = 3 For i = tRect.left + 3 To tRect.right - 3 l = i: k = 0 For j = tRect.top + 3 To tRect.bottom - i - 1 + tRect.left l = l + 1: lc = Target.Point(l, j) Select Case lc Case 0 Target.PSet (l, j), dGrau If Target.Point(l + 1, j + 1) <> 0 Then k = True Case Else If k Then If lc <> Weiss Then Target.PSet (l, j), Weiss k = False Else If lc <> hGrau Then lc = hGrau: Target.PSet (l, j), lc End If End If End Select Next j Next i k = False For i = tRect.top + 2 To tRect.bottom 'Stop l = i: k = 0 For j = tRect.left + 3 To tRect.right - i - 4 + tRect.top l = l + 1 lc = Target.Point(j, l) Select Case lc Case 0 Target.PSet (j, l), dGrau If Target.Point(j + 1, l + 1) <> 0 Then k = True Case Else If k Then If lc <> Weiss Then Target.PSet (j, l), Weiss k = False Else If lc <> hGrau Then lc = hGrau: Target.PSet (j, l), lc End If End If End Select Next j Next i Target.ScaleMode = osm End Sub Private Sub vbQHMakeEnable (tRect As apiRect, pb As PictureBox, ToolNr As Integer) Dim rc As Integer ToolSource(ToolNr).Parent.Source.Picture = ToolSource(ToolNr) rc = StretchBlt(pb.hDC, tRect.left, tRect.top, tRect.right, tRect.bottom, ToolSource(ToolNr).Parent.Source.hDC, 0, 0, tRect.right, tRect.bottom, srcCopy) If Not UseFloatingTool Then Unload ToolSource(ToolNr).Parent End If pb.Refresh End Sub Sub vbQHShowTool () Unload FloatingToolbar ' unload form Toolbar.Visible = True ' show toolbar End Sub Function vbQHToolBarMove (Target As PictureBox) As Integer Dim i As Integer, g As Integer, h As Integer, t As Integer, l As Integer Dim wRect As apiRect, tRect As apiRect Dim mPos As apiPoint, tPos As apiPoint vbQHToolBarMove = qhNoTool ' return value If Target = MDIParent.Toolbar Then If GetKeyState(1) < 0 Then ' if mouse_down GetWindowRect Target.hWnd, wRect ' get rect of toolbar GetCursorPos mPos ' get mouse position For i = 0 To ToolCnt - 1 ' on all tools If TooloTarget(i) = Target Then ' if this target ' calc width of tools tRect.right = tRect.right + mTools(i).Pos.right If h < mTools(i).Pos.bottom Then h = mTools(i).Pos.bottom If g < mTools(i).Group Then g = mTools(i).Group End If Next i i = False tRect.right = tRect.right + g * 5 + 2 * GetSystemMetrics(32) tRect.bottom = h + 6 + 2 * GetSystemMetrics(33) + 8 Do DoEvents GetCursorPos mPos ' get mouse position If Not zisPointInRect(mPos, wRect) Then ' mouse not over toolbar If zvbQHToolFakeMove(tRect, Target) Then ' move form GetCursorPos mPos ' get mouse position If Not zisPointInRect(mPos, wRect) Then ' mouse not over toolbar Target.Visible = False ' hide toolbar lw = 0 Load FloatingToolbar ' load form FTTitle = FloatingToolbar.Tag If FloatingToolbar.MDIChild Then t = mPos.Y - GetSystemMetrics(4) - GetSystemMetrics(15) - Target.Parent.Top / Screen.TwipsPerPixelY - GetSystemMetrics(33) l = mPos.X - GetSystemMetrics(32) - Target.Parent.Left / Screen.TwipsPerPixelX Else t = mPos.Y l = mPos.X End If FloatingToolbar.Move l * Screen.TwipsPerPixelX, t * Screen.TwipsPerPixelY, tRect.right * Screen.TwipsPerPixelX, tRect.bottom * Screen.TwipsPerPixelY ChangeBar = True FloatingToolbar.Show 'vbQHCalcToolPos FloatingToolbar ' copy tools and move form i = True End If End If End If Loop Until GetKeyState(1) >= 0 ' mouse_up End If End If End Function Private Sub vbQHTools (nr As Integer) Select Case nr Case qhAppExit Exit Sub Case qhNoBar ' nop Case qhNotUsed ' nop Case qhNoTool lblstatus.Caption = cReady Case Else ToolCalled nr, lblstatus End Select End Sub Sub vbQHUsed (ByVal Flag As Integer) qHelp = Flag End Sub Private Function zisPointInRect (MyPoint As apiPoint, MyRect As apiRect) As Integer If MyPoint.X > MyRect.left And MyPoint.X < MyRect.right And MyPoint.Y > MyRect.top And MyPoint.Y < MyRect.bottom Then zisPointInRect = True End Function Private Function zisPointInRectExt (MyPoint As apiPoint, MyRect As apiRect) As Integer If MyPoint.X > MyRect.left And MyPoint.X < MyRect.right + MyRect.left And MyPoint.Y > MyRect.top And MyPoint.Y < MyRect.bottom + MyRect.top Then zisPointInRectExt = True End Function Private Function zvbGetCursorExt (cPoint As apiPoint) As Integer Dim hCur As Integer, rc As Integer Dim hsx As Integer, hsy As Integer hCur = GetCursor() ' get cursor rc = DrawIcon(wndQHelp.hDC, 0, 0, hCur) ' copy cursor wndQHelp.Refresh For hsy = GetSystemMetrics(14) To 1 Step -1 ' get x,y ext of cursor For hsx = GetSystemMetrics(13) To 1 Step -1 If wndQHelp.Point(hsx, hsy) = 0 Then cPoint.Y = hsy ' return x and y cPoint.X = hsx zvbGetCursorExt = True GoTo vbGetCursorExtExit ' exit sub End If 'vbQHelpForm.PSet (hsx, hsy) Next hsx Next hsy vbGetCursorExtExit: wndQHelp.Cls ' clear form End Function Private Function zvbQHToolFakeMove (fRect As apiRect, Target As PictureBox) As Integer Dim dc As Integer, dx As Integer, dy As Integer, X As Integer, Y As Integer Dim status As Integer Dim mPos As apiPoint, oldPos As apiPoint Dim mRect As apiRect, wRect As apiRect, lRect As apiRect, cRect As apiRect MP_Alt = Screen.MousePointer ' store cursor status = True GetWindowRect Target.hWnd, wRect zGetInnerRect Target.Parent, cRect cRect.bottom = cRect.top + Target.Parent.ScaleHeight / Screen.TwipsPerPixelY + 1 If Target.Align = 1 Then lRect.left = wRect.left lRect.top = cRect.bottom' - 10' - wRect.bottom + wRect.top lRect.right = wRect.right lRect.bottom = cRect.bottom + wRect.bottom - wRect.top Else lRect.left = wRect.left lRect.top = cRect.top lRect.right = wRect.right lRect.bottom = cRect.top + wRect.bottom - wRect.top mRect = wRect wRect = lRect lRect = mRect End If Screen.MousePointer = 1 ' set cursor dc = CreateDC("DISPLAY", 0, 0, 0) ' create dc GetCursorPos mPos ' get mouse position oldPos = mPos mRect.left = fRect.left + mPos.X ' calc new draw rect mRect.top = fRect.top + mPos.Y mRect.right = fRect.right + mPos.X mRect.bottom = fRect.bottom + mPos.Y DrawFocusRect dc, mRect ' draw rect Do DoEvents Screen.MousePointer = 1 ' set cursor oldPos = mPos GetCursorPos mPos ' get mouse position, if changed If oldPos.X <> mPos.X Or oldPos.Y <> mPos.Y Then DrawFocusRect dc, mRect ' clear old rect If zisPointInRect(mPos, wRect) Then mRect = wRect ' set rect not to move ElseIf zisPointInRect(mPos, lRect) Then mRect = lRect ' set rect not to move Else mRect.left = fRect.left + mPos.X ' calc new rect mRect.top = fRect.top + mPos.Y mRect.right = fRect.right + mPos.X mRect.bottom = fRect.bottom + mPos.Y End If DrawFocusRect dc, mRect ' draw new rect End If Loop While GetKeyState(1) < 0 ' mouse_up DrawFocusRect dc, mRect ' clear old rect dc = DeleteDC(dc) ' delete dc If zisPointInRect(mPos, wRect) Then Target.Align = 1 status = False MakeStatusBar Target ElseIf zisPointInRect(mPos, lRect) Then Target.Align = 2 status = False MakeStatusBar Target End If zvbQHToolFakeMove = status Screen.MousePointer = MP_Alt ' restore cursor End Function 
